      SUBROUTINE DMTRAC1SO(IRREPZL,IRREPZR,POP,DISSYZ,NUMDSZ,
     &                   F,Z)
C
      use mod_iop
      IMPLICIT NONE
      INTEGER, intent(in) :: IRREPZL, IRREPZR, POP(8), DISSYZ 
      INTEGER, intent(in) :: NUMDSZ
      REAL*4, intent(in) :: Z(*), F(*)
C
      IF(PREC==8) THEN 
         CALL DMTRAC1(IRREPZL,IRREPZR,POP,DISSYZ,NUMDSZ,F,Z)
      ELSEIF(PREC==4) THEN
         CALL DMTRAC1S(IRREPZL,IRREPZR,POP,DISSYZ,NUMDSZ,F,Z)
      ELSE
         write(6,*)'error in parameter PREC/=8 and 4'
         stop
      ENDIF
      RETURN
      END
      SUBROUTINE DMTRAC1(IRREPZL,IRREPZR,POP,DISSYZ,NUMDSZ,
     &                   F,Z)
C
C  THIS ROUTINE CALCULATES THE GENERAL CONTRACTION
C
C  F(M,I) = F(M,I) + SUM N Z(MN,IN)
C
C  THE CONSIDERED SPIN CASE IS HERE AAAA OR BBBB ONLY, Z
C  IS STORED AS M<N: I, N , BUT THE SUM RUNS OVER ALL
C  M AND N AND ONE MUST USE THE ANTISYMMETRY OF Z
C 
C   Z(MN,IN) = - Z(NM,IN)
C
C  THIS TERM IS REQUIRED IN UHF-CCSD ONLY
C
CEND
C
C  CODED JULY/90   JG
C
      USE MOD_SYMM
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER DISSYZ,POP
      DIMENSION F(*),Z(DISSYZ,NUMDSZ),POP(8),IPF(8),IPZ(8)
C
      IRREPX=DIRPRD(IRREPZL,IRREPZR)
      IPF(1)=0
      IPZ(1)=0
      DO 1 IRREPJ=1,NIRREP-1
       IRREPI=DIRPRD(IRREPX,IRREPJ) 
       IPF(IRREPJ+1)=IPF(IRREPJ)+POP(IRREPI)*POP(IRREPJ)
       IRREPI=DIRPRD(IRREPZL,IRREPJ) 
       IF(IRREPI.LT.IRREPJ) THEN
        IPZ(IRREPJ+1)=IPZ(IRREPJ)+POP(IRREPJ)*POP(IRREPI)
       ELSE IF(IRREPI.EQ.IRREPJ) THEN
        IPZ(IRREPJ+1)=IPZ(IRREPJ)+POP(IRREPJ)*(POP(IRREPJ)-1)/2
       ELSE
        IPZ(IRREPJ+1)=IPZ(IRREPJ)
       ENDIF
1     CONTINUE
C
      IOFFZ1=0
      DO 100 IRREPM=1,NIRREP
       NOCCM=POP(IRREPM)
       IRREPJ=DIRPRD(IRREPM,IRREPZR)
       NOCCJ=POP(IRREPJ)
       IRREPI=DIRPRD(IRREPM,IRREPZL)
       NOCCI=POP(IRREPI)
C       IF(NOCCI.EQ.0.OR.NOCCJ.EQ.0) GO TO 101
       INDF=IPF(IRREPJ)
       DO 20 J=1,NOCCJ
       DO 20 I=1,NOCCI
        INDF=INDF+1
        IF(IRREPI.LT.IRREPM) THEN
         IOFFZ2=IPZ(IRREPM)
         DO 2 N=1,NOCCM
          INDN1=(N-1)*NOCCJ+J+IOFFZ1
          INDN2=(N-1)*NOCCI+I+IOFFZ2
          F(INDF)=F(INDF)+Z(INDN2,INDN1)
2        CONTINUE
        ELSE IF(IRREPI.GT.IRREPM) THEN
         IOFFZ2=IPZ(IRREPI)
         DO 3 N=1,NOCCM
          INDN1=(N-1)*NOCCJ+J+IOFFZ1
C          INDN2=(I-1)*NOCCI+N+IOFFZ2
          INDN2=(I-1)*NOCCM+N+IOFFZ2
          F(INDF)=F(INDF)-Z(INDN2,INDN1)
3        CONTINUE
        ELSE IF(IRREPI.EQ.IRREPM) THEN
         IOFFZ2=IPZ(IRREPM)
         DO 4 N=1,I-1
          INDN1=(N-1)*NOCCJ+J+IOFFZ1
          INDN2=N+((I-1)*(I-2))/2+IOFFZ2 
          F(INDF)=F(INDF)-Z(INDN2,INDN1)
4        CONTINUE
         DO 5 N=I+1,NOCCM
          INDN1=(N-1)*NOCCJ+J+IOFFZ1
          INDN2=I+((N-1)*(N-2))/2+IOFFZ2
          F(INDF)=F(INDF)+Z(INDN2,INDN1)
5        CONTINUE
        ENDIF
20     CONTINUE
       IOFFZ1=IOFFZ1+NOCCJ*NOCCM
100   CONTINUE
      RETURN
      END
      SUBROUTINE DMTRAC1S(IRREPZL,IRREPZR,POP,DISSYZ,NUMDSZ,
     &                   F,Z)
C
C  THIS ROUTINE CALCULATES THE GENERAL CONTRACTION
C
C  F(M,I) = F(M,I) + SUM N Z(MN,IN)
C
C  THE CONSIDERED SPIN CASE IS HERE AAAA OR BBBB ONLY, Z
C  IS STORED AS M<N: I, N , BUT THE SUM RUNS OVER ALL
C  M AND N AND ONE MUST USE THE ANTISYMMETRY OF Z
C 
C   Z(MN,IN) = - Z(NM,IN)
C
C  THIS TERM IS REQUIRED IN UHF-CCSD ONLY
C
CEND
C
C  CODED JULY/90   JG
C
      USE MOD_SYMM
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      INTEGER DISSYZ
      REAL*4 F(*),Z(DISSYZ,NUMDSZ)
      INTEGER POP(8),IPF(8),IPZ(8)
C
      IRREPX=DIRPRD(IRREPZL,IRREPZR)
      IPF(1)=0
      IPZ(1)=0
      DO 1 IRREPJ=1,NIRREP-1
       IRREPI=DIRPRD(IRREPX,IRREPJ) 
       IPF(IRREPJ+1)=IPF(IRREPJ)+POP(IRREPI)*POP(IRREPJ)
       IRREPI=DIRPRD(IRREPZL,IRREPJ) 
       IF(IRREPI.LT.IRREPJ) THEN
        IPZ(IRREPJ+1)=IPZ(IRREPJ)+POP(IRREPJ)*POP(IRREPI)
       ELSE IF(IRREPI.EQ.IRREPJ) THEN
        IPZ(IRREPJ+1)=IPZ(IRREPJ)+POP(IRREPJ)*(POP(IRREPJ)-1)/2
       ELSE
        IPZ(IRREPJ+1)=IPZ(IRREPJ)
       ENDIF
1     CONTINUE
C
      IOFFZ1=0
      DO 100 IRREPM=1,NIRREP
       NOCCM=POP(IRREPM)
       IRREPJ=DIRPRD(IRREPM,IRREPZR)
       NOCCJ=POP(IRREPJ)
       IRREPI=DIRPRD(IRREPM,IRREPZL)
       NOCCI=POP(IRREPI)
C       IF(NOCCI.EQ.0.OR.NOCCJ.EQ.0) GO TO 101
       INDF=IPF(IRREPJ)
       DO 20 J=1,NOCCJ
       DO 20 I=1,NOCCI
        INDF=INDF+1
        IF(IRREPI.LT.IRREPM) THEN
         IOFFZ2=IPZ(IRREPM)
         DO 2 N=1,NOCCM
          INDN1=(N-1)*NOCCJ+J+IOFFZ1
          INDN2=(N-1)*NOCCI+I+IOFFZ2
          F(INDF)=F(INDF)+Z(INDN2,INDN1)
2        CONTINUE
        ELSE IF(IRREPI.GT.IRREPM) THEN
         IOFFZ2=IPZ(IRREPI)
         DO 3 N=1,NOCCM
          INDN1=(N-1)*NOCCJ+J+IOFFZ1
C          INDN2=(I-1)*NOCCI+N+IOFFZ2
          INDN2=(I-1)*NOCCM+N+IOFFZ2
          F(INDF)=F(INDF)-Z(INDN2,INDN1)
3        CONTINUE
        ELSE IF(IRREPI.EQ.IRREPM) THEN
         IOFFZ2=IPZ(IRREPM)
         DO 4 N=1,I-1
          INDN1=(N-1)*NOCCJ+J+IOFFZ1
          INDN2=N+((I-1)*(I-2))/2+IOFFZ2 
          F(INDF)=F(INDF)-Z(INDN2,INDN1)
4        CONTINUE
         DO 5 N=I+1,NOCCM
          INDN1=(N-1)*NOCCJ+J+IOFFZ1
          INDN2=I+((N-1)*(N-2))/2+IOFFZ2
          F(INDF)=F(INDF)+Z(INDN2,INDN1)
5        CONTINUE
        ENDIF
20     CONTINUE
       IOFFZ1=IOFFZ1+NOCCJ*NOCCM
100   CONTINUE
      RETURN
      END
